home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.003 / stk-3 / stk / 3.1 / STk / Multipaned.stklos < prev    next >
Encoding:
Text File  |  1996-07-29  |  7.4 KB  |  212 lines
  1. ;;;;
  2. ;;;; M u l t i p a n e d . s t k
  3. ;;;;
  4. ;;;; Rewritten version of Paned.stk to allow an arbitrary number of panes.
  5. ;;;; Modified by Harvey J. Stein <hjstein@math.huji.ac.il>
  6. ;;;; Modified again by Erick Gallesio for allowing horizontal and vertical
  7. ;;;; placement
  8. ;;;;
  9. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  10. ;;;; 
  11. ;;;; Permission to use, copy, and/or distribute this software and its
  12. ;;;; documentation for any purpose and without fee is hereby granted, provided
  13. ;;;; that both the above copyright notice and this permission notice appear in
  14. ;;;; all copies and derived works.  Fees for distribution or use of this
  15. ;;;; software or derived works may only be charged with express written
  16. ;;;; permission of the copyright holder.  
  17. ;;;; This software is provided ``as is'' without express or implied warranty.
  18. ;;;;
  19. ;;;; Idea of this implementation was found in comp.lang.tcl. 
  20. ;;;; Original author seems to be James Noble and the version from which this 
  21. ;;;; stuff is derivated is Jay Schmidgall (shmdgljd@ghostwind.rchland.ibm.com).
  22.  
  23. (require "Tk-classes")
  24.  
  25. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26. ;;;;
  27. ;;;; <MultiPaned> class definition
  28. ;;;;
  29. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30.  
  31. (define-class <MultiPaned> (<Tk-composite-widget>)
  32.   (;; Public slots
  33.    (frames       :accessor     frames-of)
  34.    (grips     :accessor     grips-of)
  35.    (ghost     :accessor     ghost-of)
  36.    (panes        :accessor     panes-of       :init-keyword :panes)
  37.    (width     :accessor     width       :init-keyword :width
  38.          :allocation   :propagated :propagate-to (frame))
  39.    (height     :accessor     height       :init-keyword :height
  40.          :allocation   :propagated :propagate-to (frame))
  41.  
  42.    ;; Virtual slot
  43.    (orientation  :accessor      orientation :allocation :virtual
  44.          :slot-ref    (lambda (o)
  45.                   (extend-environment (environment o)
  46.                      (if vertical? "vertical" "horizontal")))
  47.          :slot-set!    (lambda (o v)
  48.                   (extend-environment (environment o)
  49.                      (set! vertical? (equal? v "vertical"))
  50.                      (place-grips o))))
  51.    ;; Private slots
  52.    (environment  :accessor     environment)
  53.    (fractions       :accessor     fractions-of)
  54.    (grip-number  :accessor     grip-number-of)
  55.    (drag-start   :accessor     drag-start-of)))
  56.  
  57. (define-method initialize-composite-widget ((self <MultiPaned>) initargs frame)
  58.   (let* ((panes     (get-keyword :panes initargs 2))
  59.      (vertical? (equal? "vertical" 
  60.                 (get-keyword :position  initargs "vertical")))
  61.      (fractions (make-vector panes))
  62.      (frames    (make-vector panes))
  63.      (grips     (make-vector (- panes 1)))
  64.      (ghost        (make <Frame> :parent frame :border-width 2 :relief "ridge")))
  65.  
  66.     ;; Build the "container" frames
  67.     (dotimes (i panes)
  68.        (vector-set! fractions i (/ (+ i 1) panes))
  69.        (vector-set! frames    i (make <Frame> :parent frame :border-width 2
  70.                               :relief "raised")))
  71.  
  72.     ;; Build grips
  73.     (dotimes (i (- panes 1))
  74.        (let ((G (make <Frame> :parent frame :width 10 :height 10 :border-width 2
  75.                   :relief "raised" :cursor "crosshair")))
  76.      (vector-set! grips i G)
  77.      ;; Associate bindings to the newly created grip
  78.      (bind G "<Button-1>"        (lambda (|W| x y) (start-grip  self x y |W|)))
  79.      (bind G "<B1-Motion>"       (lambda (x y)     (motion-grip self x y)))
  80.      (bind G "<ButtonRelease-1>" (lambda (x y)     (stop-grip self x y)))))
  81.  
  82.     ;; Initialize slots
  83.     (slot-set! self 'environment (the-environment))
  84.     (slot-set! self 'panes      panes)
  85.     (slot-set! self 'frames     frames)
  86.     (slot-set! self 'grips     grips)
  87.     (slot-set! self 'fractions   fractions)
  88.     (slot-set! self 'ghost     ghost)
  89.     (slot-set! self 'Id         (Id frame))
  90.  
  91.     ;; Place grips
  92.     (place-grips self)))
  93.  
  94. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  95. ;;;
  96. ;;; <MultiPaned> methods 
  97. ;;; 
  98. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  99.  
  100. (define-method place-grips ((self <MultiPaned>))
  101.   (extend-environment (environment self)
  102.     (let ((f     0)
  103.       (fp    0))
  104.       ;; Place frames and grips
  105.       (dotimes (i (- panes 1))
  106.      (set! f (vector-ref fractions i))
  107.      (if vertical?
  108.          (begin
  109.            (place (vector-ref grips i)  :rely 0.95   :relx f  :anchor "center")
  110.            (place (vector-ref frames i) :y 0 :relh 1 :relx fp :relw (- f fp)))
  111.           (begin
  112.         (place (vector-ref grips i)  :relx 0.95   :rely f  :anchor "center")
  113.         (place (vector-ref frames i) :x 0 :relw 1 :rely fp :relh (- f fp))))
  114.       (raise (vector-ref grips i))
  115.       (set! fp f))
  116.       
  117.       ;; Last frame
  118.       (if vertical?
  119.       (place (vector-ref frames (- panes 1))
  120.          :y 0 :relx f :relheight 1 :relwidth (- 1.0 f))
  121.       (place (vector-ref frames (- panes 1))
  122.          :x 0 :rely f :relwidth 1 :relheight (- 1.0 f))))))
  123.  
  124. ;;;
  125. ;;; Methods for moving grips
  126. ;;;
  127. (define-method find-grip ((self <MultiPaned>) w)
  128.   (do ((i 0 (+ 1 i)))
  129.       ((eq? w (slot-ref (vector-ref (grips-of self) i) 'id)) i)))
  130.  
  131. (define-method start-grip ((self <MultiPaned>) x y w)
  132.   (extend-environment (environment self)
  133.     (let* ((grip   (find-grip self w))
  134.        (ghost  (ghost-of self))
  135.        (fracts (fractions-of self))
  136.        (fr     (vector-ref fracts grip)))
  137.       
  138.       (slot-set! self 'grip-number grip)
  139.       (slot-set! self 'drag-start (cons x y))
  140.  
  141.       ;; Raise ghost
  142.       (place 'forget ghost) ; otherwise old constaints seems to stay valid
  143.       (if vertical?
  144.       (place ghost :rely 0 :relx fr :anchor "n" :relh 1)
  145.       (place ghost :relx 0 :rely fr :anchor "w" :relw 1))
  146.       (raise ghost)
  147.  
  148.       ;; Raise current grip
  149.       (raise (vector-ref (grips-of self)  grip)))))
  150.  
  151. (define-method motion-grip ((self <MultiPaned>) x y)
  152.   (extend-environment (environment self)
  153.      (let ((fraction (fractions-of self))
  154.        (gn       (grip-number-of self))
  155.        (ghost      (ghost-of self)))
  156.  
  157.        (if vertical?
  158.        (begin
  159.          (vector-set! fraction 
  160.               gn
  161.               (max 0.0001
  162.                    (min .9999
  163.                     (+ (vector-ref fraction gn)
  164.                        (/ (- x (car (drag-start-of self)))
  165.                       (+ 1 (winfo 'width (frame-of self))))))))
  166.          (place ghost
  167.             :rely 0 :relheight 1 :relx (vector-ref fraction gn) :anchor "n")
  168.       (place (vector-ref (grips-of self) gn)
  169.          :rely 0.95 :relx (vector-ref fraction gn) :anchor "center"))
  170.        (begin
  171.          (vector-set! fraction 
  172.               gn
  173.                (max 0.0001
  174.                 (min .9999
  175.                  (+ (vector-ref fraction gn)
  176.                     (/ (- y (cdr (drag-start-of self)))
  177.                        (+ 1 (winfo 'height (frame-of self))))))))
  178.          (place ghost
  179.          :relx 0 :relwidth 1 :rely (vector-ref fraction gn) :anchor "w")
  180.          (place (vector-ref (grips-of self) gn)
  181.          :relx 0.95 :rely (vector-ref fraction gn) :anchor "center"))))))
  182.  
  183. (define-method stop-grip ((self <MultiPaned>) x y)
  184.   (let* ((gn         (grip-number-of self))
  185.      (fractions (fractions-of self))
  186.      (cp        (vector-ref fractions gn)))
  187.     (dotimes (i (- (panes-of self) 1))
  188.       (cond 
  189.        ((and (< i gn) (> (vector-ref fractions i) cp))
  190.         (vector-set! fractions i cp))
  191.        ((and (> i gn) (< (vector-ref fractions i) cp))
  192.         (vector-set! fractions i cp)))))
  193.   (lower (ghost-of self))
  194.   (place-grips self))
  195.  
  196. (provide "Multipaned")
  197.  
  198. ;;;
  199. ;;; Example of usage
  200. ;;;
  201. ;;; (define p (make <MultiPaned> 
  202. ;;;         :panes 4 
  203. ;;;         :width 400 :height 400
  204. ;;;         :orientation "horizontal"))
  205. ;;; 
  206. ;;; (define l0 (make <Label> :text "Lab0" :parent (vector-ref (frames-of p) 0)))
  207. ;;; (define l1 (make <Label> :text "Lab1" :parent (vector-ref (frames-of p) 1)))
  208. ;;; (define l2 (make <Label> :text "Lab2" :parent (vector-ref (frames-of p) 2)))
  209. ;;; (pack l0 l1 l2 :expand #t :fill "both")
  210. ;;; (pack p :expand #t)
  211. ;;; 
  212.